(defpackage :operations
    (:use :cl :diagram)
  (:nicknames :op :o)
  (:export :transformation
           :recon
           :old-tree
           :new-tree
           :hint
           :mistake
           :surgeryp
           :check-function
           :reward
           :operation
           :name
           :quick-key
           :transformations
           :generate-new-tree
           :transformation-matches-p
           :generate-tree
           :find-transformation-for
           :perform-operation
           :generate-answers
           :empty-green-boxes-p
           :collapse-input-argument
           :collapse-input-arguments
           :no-more-valid-operations-p
           ))

(in-package :operations)

(defclass transformation ()
  ((old-tree :initarg :old-tree :accessor old-tree)
   (new-tree :initarg :new-tree :accessor new-tree)
   (hint :initform nil :initarg :hint :accessor hint)
   (mistake :initform nil :initarg :mistake :accessor mistake)
   (surgeryp :initform t :initarg :surgeryp :accessor surgeryp
             :documentation "non-NIL means this transformation
performs graph surgery and a previous diagram state might be needed to
understand what happened.")
   (check-function :initform nil :initarg :check-function :accessor check-function)
   (reward :initform nil :initarg :reward :accessor reward :documentation "Override the default reward.")))

(defclass recon (transformation)
  ((root :initarg :root :accessor root))
  (:documentation "First recon matches the tree using the template in
OLD-TREE. Instead of defaulting to the node matched by OLD-TREE, ROOT is
used which references a variable captured from OLD-TREE."))

(defgeneric transformation-matches-p (transformation root ignore-selected-p))
(defgeneric generate-new-tree (transformation vars))
(defgeneric generate-answers (transformation tree))

(defclass operation ()
  ((name :initarg :name :accessor name)
   (quick-key :initarg :quick-key :accessor quick-key)
   (transformations :initarg :transformations :accessor transformations)
   (hint :initform nil :initarg :hint :accessor hint)))

(defmacro with-template ((template data data-var) &rest bodies)
  (let ((node (gensym "NODE"))
        (node-type (gensym "NODE-TYPE"))
        (operator (cdr (find :operator bodies :key 'first)))
        (multi (cdr (find :multi bodies :key 'first)))
        (argument (cdr (find :argument bodies :key 'first)))
        (number-input (cdr (find :number-input bodies :key 'first)))
        (operator-input (cdr (find :operator-input bodies :key 'first)))
        (number-operator-input (cdr (find :number-operator-input bodies :key 'first)))
        (operator-number-input (cdr (find :operator-number-input bodies :key 'first)))
        (number-operator-number-input (cdr (find :number-operator-number-input bodies :key 'first)))
        (atom (cdr (find :atom bodies :key 'first)))
        (single (cdr (find :single bodies :key 'first)))
        (null (cdr (find :null bodies :key 'first)))
        (extraneous-tag (find-if-not (lambda (x) (find (first x) '(:operator :multi :argument :number-input :operator-input :operator-number-input :number-operator-input :number-operator-number-input
                                                                   :atom :single :null)))
                                 bodies)))
    (assert (null extraneous-tag)
            ()
            "Extraneous tag ~a" (first extraneous-tag))
    `(labels ((extract (elts)
                (let* ((p (position-if 'keywordp elts))
                       (children (subseq elts 0 p))
                       (keywords (when p (subseq elts p))))
                  (values children keywords)))
              (recurse (,node ,data-var)
                (cond
                  ((null ,node) ,@null)
                  ((listp ,node)
                   (let ((,node-type (first ,node)))
                     (cond
                       ((find ,node-type '(operator o) :key 'symbol-name :test 'string=)
                        (let* ((p (position-if 'keywordp (rest ,node)))
                               (%children% (subseq (rest ,node) 0 p))
                               (%keywords% (when p (subseq (rest ,node) p))))
                          ,@operator))
                       ((find ,node-type '(multiple-arg-box multi m) :key 'symbol-name :test 'string=)
                        (let* ((p (position-if 'keywordp (rest ,node)))
                               (%children% (subseq (rest ,node) 0 p))
                               (%keywords% (when p (subseq (rest ,node) p))))
                          ,@multi))
                       ((find ,node-type '(+ - * /) :key 'symbol-name :test 'string=)
                        (let* ((p (position-if 'keywordp ,node))
                               (%children% (cons `(argument ,,node-type)
                                                 (subseq ,node 1 p)))
                               (%keywords% (when p (subseq ,node p))))
                          ,@operator))
                       ((find ,node-type '(argument a) :key 'symbol-name :test 'string=)
                        (multiple-value-bind (%children% %keywords%) (extract (cddr ,node))
                          (declare (ignorable %keywords%))
                          (let ((%quantity% (second ,node))
                                (%child% (first %children%)))
                            (declare (ignorable %quantity% %child%))
                            ,@argument)))
                       ((find ,node-type '(number-input i ni) :key 'symbol-name :test 'string=)
                        (multiple-value-bind (%children% %keywords%) (extract (cddr ,node))
                          (declare (ignorable %keywords%))
                          (let ((%quantity% (second ,node))
                                (%child% (first %children%)))
                            (declare (ignorable %quantity% %child%))
                            ,@number-input)))
                       ((find ,node-type '(operator-input oi) :key 'symbol-name :test 'string=)
                        (destructuring-bind (&optional %quantity% &rest %keywords% &key &allow-other-keys) (rest ,node)
                          (declare (ignorable %quantity% %keywords%))
                          ,@operator-input))
                       ((find ,node-type '(number-operator-input noi) :key 'symbol-name :test 'string=)
                        (destructuring-bind (%quantity% &rest %keywords% &key &allow-other-keys) (rest ,node)
                          (declare (ignorable %quantity% %keywords%))
                          ,@number-operator-input))
                       ((find ,node-type '(operator-number-input oni) :key 'symbol-name :test 'string=)
                        (destructuring-bind (%quantity% &rest %keywords% &key &allow-other-keys) (rest ,node)
                          (declare (ignorable %quantity% %keywords%))
                          ,@operator-number-input))
                       ((find ,node-type '(number-operator-number-input noni) :key 'symbol-name :test 'string=)
                        (destructuring-bind (%quantity% &rest %keywords% &key &allow-other-keys) (rest ,node)
                          (declare (ignorable %quantity% %keywords%))
                          ,@number-operator-number-input))
                       ((find ,node-type '(single s) :key 'symbol-name :test 'string=)
                        (destructuring-bind (%child% &rest %keywords% &key &allow-other-keys) (rest ,node)
                        (declare (ignorable %child% %keywords%))
                          ,@single))
                       (t (error "what is this? ~a" ,node)))))
                  (t
                   (let ((%atom% ,node))
                     ,@atom)))))
       (recurse ,template ,data))))

(defun match-template (tree template &optional ignore-selected)
  (let (vars nodes-needing-selection)
    (labels ((match-keywords (node keywords)
               (or ignore-selected
                   (eq (selected node) (getf keywords :selected))))
             (store-selection (node keywords)
               (when (getf keywords :selected)
                 (push node nodes-needing-selection)))
             (conflict-p (value key)
               (let ((pair (find key vars :key 'first)))
                 (when pair
                   (not (equal (second pair) value)))))
             (node-var-conflict-p (node keywords)
               (when (getf keywords :store)
                 (conflict-p node (getf keywords :store))))
             (maybe-store-node (node keywords)
               (when (getf keywords :store)
                 (store (getf keywords :store) node)))
             (fchar (symbol)
               (char-downcase (char (symbol-name symbol) 0)))
             (dontcare (thing)
               (and (symbolp thing)
                    (find thing '(_ :dontcare) :test 'string=)))
             (match-quantity (tree quantity)
               (or (dontcare quantity)
                   (and quantity  ; NIL is a symbol that starts with n
                        (symbolp quantity)
                        (char= (fchar quantity) #\n)
                        (numberp (quantity tree)))
                   (and (symbolp quantity)
                        (char= (fchar quantity) #\o)
                        (find (quantity tree) '(+ - * /)))
                   (and (symbolp quantity)
                        (char= (fchar quantity) #\a)
                        (find (quantity tree) '(+ -)))
                   (and (symbolp quantity)
                        (char= (fchar quantity) #\m)
                        (find (quantity tree) '(* /)))
                   (eql quantity (quantity tree))))
             (store (key val)
               ;; store a copy of the node so it can't be accidentally
               ;; manipulated elsewhere.
               (pushnew `(,key ,val
                            ;; (if (typep val 'tree:base-node)
                            ;; (tree:copy-node val t)
                            ;; val)
                            )
                        vars :key 'first))
             (storeq (key tree)
               (when (and (symbolp key)
                          (not (find key '(+ - * /))))
                 (store key (quantity tree))))
             (match-children (c1 c2 fn)
               ;; treat a single element in c1 to mean a symbol as
               ;; opposed to meaning one element that matches it.
               (or (and (= (length c1) 1)
                        (funcall fn (first c1) c2))
                   (and (eql (length c1) (length c2))
                        (loop
                           for a in c1
                           for b in c2
                           always (funcall fn a b))))))
      (values
       (with-template (template tree tree)
         (:operator
          (when (and (eq (type-of tree) 'operator-box)
                     (match-keywords tree %keywords%)
                     (not (node-var-conflict-p tree %keywords%)))
            (store-selection tree %keywords%)
            (maybe-store-node tree %keywords%)
            (match-children %children% (tree:children tree) #'recurse)))
         (:multi
          (when (and (eq (type-of tree) 'multi-argument-box)
                     (match-keywords tree %keywords%)
                     (not (node-var-conflict-p tree %keywords%)))
            (store-selection tree %keywords%)
            (maybe-store-node tree %keywords%)
            (match-children %children% (tree:children tree) #'recurse)))
         (:argument
          (when (and (eq (type-of tree) 'argument)
                     (match-quantity tree %quantity%)
                     (not (conflict-p (d:quantity tree) %quantity%))
                     (match-keywords tree %keywords%)
                     (not (node-var-conflict-p tree %keywords%)))
            (store-selection tree %keywords%)
            (maybe-store-node tree %keywords%)
            (unless (or (null %quantity%)
                        (dontcare %quantity%))
              (storeq %quantity% tree))
            (match-children %children% (tree:children tree) #'recurse)))
         (:number-input
          (when (and (typep (type-of tree) 'number-input-argument)
                     (match-quantity tree %quantity%)
                     (not (conflict-p (d:quantity tree) %quantity%))
                     (match-keywords tree %keywords%))
            (store-selection tree %keywords%)
            (storeq %quantity% tree)
            (match-children %children% (tree:children tree) #'recurse)))
         (:operator-input
          (when (and (typep (type-of tree) 'operator-input-argument)
                     (match-quantity tree %quantity%)
                     (not (conflict-p (d:quantity tree) %quantity%))
                     (match-keywords tree %keywords%))
            (store-selection tree %keywords%)
            (storeq %quantity% tree)))
         (:single
          (when (and (eq (type-of tree) 'single-box)
                     (match-keywords tree %keywords%))
            (store-selection tree %keywords%)
            (recurse %child% (tree:child tree))))
         (:atom
          ;; this is where we match boxes
          (if (symbolp %atom%)
              (cond
                ((dontcare %atom%)
                 t)
                ((and (or (and (char= (fchar %atom%) #\b)
                               (typep tree 'box))
                          (and (char= (fchar %atom%) #\s)
                               (typep tree 'single-box))
                          (and (char= (fchar %atom%) #\x)
                               (typep tree 'unknown-box))
                          (and (char= (fchar %atom%) #\w)
                               (or (null tree)
                                   (typep tree 'box)
                                   (and (listp tree)
                                        (every (lambda (b) (typep b 'box)) tree)))))
                      (not (conflict-p tree %atom%)))
                 (store %atom% tree)))
              (error "it has to be a symbol")))
         (:null (null tree)))
       vars
       nodes-needing-selection))))

(defun generate-tree (vars template)
  (labels ((eval-it (thing)
             (if (and (listp thing)
                      (eq (first thing) :eval))
                 (eval `(let ,(mapcar (lambda (v) `(,(first v) (quote ,(second v)))) vars) ,@(cdr thing)))
                 thing))
           (lookup (thing)
             (setf thing (eval-it thing))
             (if (and (symbolp thing)
                      (assoc thing vars))
                 (second (assoc thing vars))
                 thing))
           (process-keywords (kw)
             (loop for i = kw then (cddr i)
                  while i
                  collect (first i)
                  collect (lookup (second i))))
           (process-children (fn children)
             (delete nil
                     (u:flatten
                      (mapcar (lambda (c) (funcall fn c nil))
                              children)))))
    (with-template (template nil data)
      (:operator
       (apply 'make-instance 'operator-box
              :children (process-children #'recurse %children%)
              (process-keywords %keywords%)))
      (:multi
       (apply 'make-instance 'multi-argument-box
              :children (process-children #'recurse %children%)
              (process-keywords %keywords%)))
      (:argument
       (apply 'make-instance 'argument
              :children (process-children #'recurse %children%)
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:number-input
       (apply 'make-instance 'number-input-argument
              :children (process-children #'recurse %children%)
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:operator-input
       (apply 'make-instance 'operator-input-argument
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:number-operator-input
       (apply 'make-instance 'number-operator-input-argument
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:operator-number-input
       (apply 'make-instance 'operator-number-input-argument
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:number-operator-number-input
       (apply 'make-instance 'number-operator-number-input-argument
              :quantity (lookup %quantity%)
              (process-keywords %keywords%)))
      (:single
       (apply 'make-instance 'single-box
              :child (recurse %child% nil)
              (process-keywords %keywords%)))
      (:atom
       (lookup %atom%))
      (:null nil))))

(defun nsubstitute-node (tree old-node new-node)
  "Substitute OLD-NODE in TREE with NEW-NODE. Destructively modifies tree."
  (dolist (i (tree:parents old-node))
    (setf (slot-value i 'tree:children) (substitute new-node old-node
                                                    (slot-value i 'tree:children))))
  (psetf (slot-value old-node 'tree:parents) nil
         (slot-value new-node 'tree:parents) (tree:parents old-node))
  (tree:recreate-parent-slots (if (eq tree old-node)
                                  new-node
                                  tree)))

(defun nsubstitute-node-by-id (tree old-node-id new-node)
  "Substitute the node with OLD-NODE-ID in TREE with NEW-NODE. Destructively modifies tree."
  (let ((old-node (find-node-by-id tree old-node-id)))
    (if old-node
        (nsubstitute-node tree old-node new-node)
        (error "no node with ID = ~a" old-node-id))))

(defmethod transformation-matches-p ((trans transformation) root ignore-selected-p)
  (multiple-value-bind (match vars selections-needed)
      (match-template root (old-tree trans) ignore-selected-p)
    (when (and match
               (or (not (u:funcallable (check-function trans)))
                   (funcall (check-function trans) trans root vars)))
      (values match root vars selections-needed))))

(defmethod transformation-matches-p ((trans recon) root ignore-selected-p)
  (multiple-value-bind (match vars selections-needed)
      (match-template root (old-tree trans) ignore-selected-p)
    (when (and match
               (or (not (u:funcallable (check-function trans)))
                   (funcall (check-function trans) trans root vars)))
      (let ((root (second (find (root trans) vars :key 'first))))
        (assert root)
        (values match root vars selections-needed)))))

(defmethod generate-new-tree ((trans transformation) vars)
  (generate-tree vars (new-tree trans)))

(defun find-transformation-for (tree transformations &optional ignore-selected)
  (dolist (trans transformations)
    (funcall-on-tree (lambda (node)
                       (multiple-value-bind (match root vars selections-needed) (transformation-matches-p trans node ignore-selected)
                         (when (and match
                                    (or ignore-selected
                                        (null (set-exclusive-or selections-needed
                                                                (selected-nodes tree)))))
                           (return-from find-transformation-for
                             (values root trans vars selections-needed)))))
                     tree)))

(defun perform-operation (root operation)
  "Perform the operation if possible. Return the new root,
transformation that was applied in such a case and match variables,
NIL otherwise. Desructively modifies root."
  (multiple-value-bind (node transformation vars selections-needed)
      (find-transformation-for root
                               (transformations operation))
    (when (and node
               (null (set-exclusive-or selections-needed (selected-nodes root))))
      (setf root
            (nsubstitute-node root
                              node
                              (generate-new-tree transformation vars)))
      (values root transformation vars))))

(defgeneric collapse-input-argument (arg))

(defmethod collapse-input-argument ((arg tree:base-node)))

(defmethod collapse-input-argument ((arg input-argument))
  (error "Don't know how to collapse ~a" (type-of arg)))

(defmethod collapse-input-argument ((arg number-input-argument))
  (change-class arg 'argument)
  (setf (quantity arg) (first (parse:num (quantity arg)))
        ;; XXX: a cheap trick to get the default argument colors
        (foreground arg) (foreground (make-instance 'argument))
        (background arg) (background (make-instance 'argument))))

(defmethod collapse-input-argument ((arg operator-input-argument))
  (change-class arg 'argument)
  (setf (quantity arg) (first (parse:op (quantity arg)))
        ;; XXX: a cheap trick to get the default argument colors
        (foreground arg) (foreground (make-instance 'argument))
        (background arg) (background (make-instance 'argument))))

;; FIXME: These collapse functions make assumptions about the tree
;; that are probably reasonable but it'd be nice if they could assume
;; less.
(defmethod collapse-input-argument ((arg number-operator-input-argument))
  (let ((parse (parse:num-op (quantity arg))))
    (setf (tree:children (tree:parent arg))
          (list*
           (make-instance 'argument
                          :quantity (first parse))
           (make-instance 'argument
                          :quantity (second parse))
           (remove arg (tree:children (tree:parent arg)))))))

(defmethod collapse-input-argument ((arg operator-number-input-argument))
  (let ((parse (parse:op-num (quantity arg))))
    (setf (tree:children (tree:parent arg))
          (list
           (first (tree:children (tree:parent arg)))
           (make-instance 'argument
                          :quantity (first parse))
           (make-instance 'argument
                          :quantity (second parse))))))

(defmethod collapse-input-argument ((arg number-operator-number-input-argument))
  (change-class (tree:parent arg) 'multi-argument-box)
  (let ((parse (parse:num-op-num (quantity arg))))
    (setf (tree:children (tree:parent arg))
          (list
           (make-instance 'argument
                          :quantity (first parse))
           (make-instance 'argument
                          :quantity (second parse))
           (make-instance 'argument
                          :quantity (third parse))))))

(defun collapse-input-arguments (tree)
  "return a copy of TREE with all input-arguments changed to regular arguments."
  (let ((copy (tree:copy-node tree t)))
    (funcall-on-tree 'collapse-input-argument copy)
    copy))

;;; Tree Permutations for calculating all possible correct answer trees

(defgeneric permute-tree (node negate allowed-nodes))
(defgeneric permute-box (n1 op op-node n2 negate allowed-nodes))

(defun knit-node (node children)
  (or
   (loop for c in (remove :fail children)
      for n = (tree:copy-node node nil)
       collect (progn
                 (setf (tree:children n) c)
                 n))
   :fail))

(defun all-combos (&rest children)
  (labels ((all-combos-helper (fn children)
             (cond
               ((null children)
                (list nil))
               (t
                (let ((head (car children))
                      (combos (all-combos-helper fn (cdr children))))
                  (loop for i in combos
                     append (loop for j in head
                               collect (cons (funcall fn j)
                                             i))))))))
    (all-combos-helper (lambda (n) (tree:copy-node n t))
                       children)))

(defun fail-or-permute-children (node negate allowed-nodes &optional (children (tree:children node)))
  (let ((p (loop for i in children
              collect (permute-tree i negate allowed-nodes))))
    (if (or (find :fail p)
            (and (null children)
                 negate))
        :fail
        (knit-node node (apply 'all-combos p)))))

(defmethod permute-tree :around ((node tree:node) negate allowed-nodes)
  (if (find (id node) allowed-nodes :key 'id)
      (call-next-method)
      (if negate
          :fail
          (list (tree:copy-node node t)))))

(defmethod permute-tree ((node multi-argument-box) negate allowed-nodes)
  (ecase (length (tree:children node))
    (3
     (knit-node node (permute-box (first (tree:children node))
                                  (quantity (second (tree:children node)))
                                  (second (tree:children node))
                                  (third (tree:children node))
                                  negate allowed-nodes)))
    (1
     (fail-or-permute-children node negate allowed-nodes))
    (0
     (list (tree:copy-node node nil)))))

(defmethod permute-tree ((node argument) negate allowed-nodes)
  (let ((c (tree:copy-node node nil)))
    (when (and negate
               (quantity c))
      (setf (quantity c) (- (quantity c))))
    (if (and negate
             (quantity c)
             (null (tree:children node)))
        (list c)
        (fail-or-permute-children c negate allowed-nodes (tree:children node)))))

(defun reverse-op (node)
  (let ((c (tree:copy-node node nil)))
    (setf (quantity C)
          (ecase (quantity c)
            (+ '-)
            (* '/)
            (- '+)
            (/ '*)))
    c))

(defmethod permute-box (n1 (op (eql '+)) op-node n2 (negate (eql nil)) allowed-nodes)
  (labels ((type-1 ()
             ;; n1 + n2
             (all-combos (permute-tree n1 nil allowed-nodes)
                         (list op)
                         (permute-tree n2 nil allowed-nodes)))
           (type-2 ()
             ;; n1 - (- n2)
             (let ((p2 (permute-tree n2 t allowed-nodes)))
               (if (eq p2 :fail)
                   (list :fail)
                   (all-combos (permute-tree n1 nil allowed-nodes)
                               (list (reverse-op op))
                               p2))))
           (type-3 ()
             ;; n2 + n1
             (when (and (d:quantity n1)
                        (d:quantity n2))
               (all-combos (permute-tree n2 nil allowed-nodes)
                           (list op)
                           (permute-tree n1 nil allowed-nodes))))
           (type-4 ()
             ;; n2 - (- n1)
             (when (and (d:quantity n1)
                        (d:quantity n2))
               (let ((p1 (permute-tree n1 t allowed-nodes)))
                 (if (eq p1 :fail)
                     (list :fail)
                     (all-combos (permute-tree n2 nil allowed-nodes)
                                 (list (reverse-op op))
                                 p1))))))
    (setf op [a op :id (d:id op-node)])
    (append (type-1) (type-2) (type-3) (type-4))))

(defmethod permute-box (n1 (op (eql '+)) op-node n2 (negate (eql t)) allowed-nodes)
  (let ((p1 (permute-tree n1 t allowed-nodes))
        (p2 (permute-tree n2 t allowed-nodes)))
    (cond
      ((and (eq p1 :fail)
            (eq p2 :fail))
       (list :fail))
      ((eq p1 :fail)
       (permute-box (first p2) '- op-node n1 nil allowed-nodes))
      ((eq p2 :fail)
       (permute-box (first p1) '- op-node n2 nil allowed-nodes))
      (t
       (permute-box (first p1) '+ op-node (first p2) nil allowed-nodes)))))

(defmethod permute-box (n1 (op (eql '-)) op-node n2 (negate (eql nil)) allowed-nodes)
  (labels ((type-1 ()
             (all-combos (permute-tree n1 nil allowed-nodes)
                         (list op)
                         (permute-tree n2 nil allowed-nodes)))
           (type-2 ()
             (let ((p (permute-tree n2 t allowed-nodes)))
               (if (eq p :fail)
                   :fail
                   (permute-box n1 '+ op-node (first p) nil allowed-nodes)))))
    (setf op [a op :id (d:id op-node)])
    ;; type-2 will generate type-1 if possible
    (let ((t2 (type-2)))
      (if (eq t2 :fail)
          (type-1)
          t2))))

(defmethod permute-box (n1 (op (eql '-)) op-node n2 (negate (eql t)) allowed-nodes)
  (let ((p1 (permute-tree n1 t allowed-nodes))
        (p2 (permute-tree n2 t allowed-nodes)))
    (cond
      ((and (eq p1 :fail)
            (eq p2 :fail))
       (list :fail))
      ((eq p1 :fail)
       (permute-box (first p2) '- op-node n1 nil allowed-nodes))
      ((eq p2 :fail)
       (permute-box (first p1) '+ op-node n2 nil allowed-nodes))
      (t
       (permute-box (first p1) '- op-node (first p2) nil allowed-nodes)))))

(defmethod permute-box (n1 (op (eql '*)) op-node n2 (negate (eql nil)) allowed-nodes)
  (labels ((type-1 ()
             ;; n1 * n2
             (all-combos (permute-tree n1 nil allowed-nodes)
                         (list op)
                         (permute-tree n2 nil allowed-nodes)))
           (type-2 ()
             ;; (- n1) * (- n2)
             (let ((p1 (permute-tree n1 t allowed-nodes))
                   (p2 (permute-tree n2 t allowed-nodes)))
               (if (or (eq p1 :fail)
                       (eq p2 :fail))
                   (list :fail)
                   (all-combos p1
                               (list op)
                               p2))))
           (type-3 ()
             ;; n2 * n1
             (all-combos (permute-tree n2 nil allowed-nodes)
                         (list op)
                         (permute-tree n1 nil allowed-nodes)))
           (type-4 ()
             ;; (- n2) * (- n1)
             (let ((p1 (permute-tree n1 t allowed-nodes))
                   (p2 (permute-tree n2 t allowed-nodes)))
               (if (or (eq p1 :fail)
                       (eq p2 :fail))
                   (list :fail)
                   (all-combos p2
                               (list op)
                               p1)))))
    (setf op [a op :id (d:id op-node)])
    (append (type-1) (type-2) (type-3) (type-4))))

(defmethod permute-box (n1 (op (eql '*)) op-node n2 (negate (eql t)) allowed-nodes)
  (let ((p1 (permute-tree n1 t allowed-nodes))
        (p2 (permute-tree n2 t allowed-nodes)))
    (cond
      ((and (eq p1 :fail)
            (eq p2 :fail))
       (list :fail))
      ((eq p1 :fail)
       (permute-box (first p2) '* op-node n1 nil allowed-nodes))
      (t
       (permute-box (first p1) '* op-node n2 nil allowed-nodes)))))

(defmethod permute-box (n1 (op (eql '/)) op-node n2 (negate (eql nil)) allowed-nodes)
  (labels ((type-1 ()
             ;; n1 / n2
             (all-combos (permute-tree n1 nil allowed-nodes)
                         (list op)
                         (permute-tree n2 nil allowed-nodes)))
           (type-2 ()
             ;; (- n1) / (- n2)
             (let ((p1 (permute-tree n1 t allowed-nodes))
                   (p2 (permute-tree n2 t allowed-nodes)))
               (if (or (eq p1 :fail)
                       (eq p2 :fail))
                   (list :fail)
                   (all-combos p1
                               (list op)
                               p2)))))
    (setf op [a op :id (d:id op-node)])
    (append (type-1) (type-2))))

(defmethod permute-box (n1 (op (eql '/)) op-node n2 (negate (eql t)) allowed-nodes)
  (let ((p1 (permute-tree n1 t allowed-nodes))
        (p2 (permute-tree n2 t allowed-nodes)))
    (cond
      ((and (eq p1 :fail)
            (eq p2 :fail))
       (list :fail))
      ((eq p1 :fail)
       (permute-box (first p2) op op-node n1 nil allowed-nodes))
      (t
       (permute-box (first p1) op op-node n2 nil allowed-nodes)))))

(defmethod generate-answers ((trans transformation) tree)
  "Given a tree and the transformation, return a list of correct
answers. Each answer is a list of pairs. Each pair is an
input-argument's ID and its correct answer. Answers are sorted by ID."
  (let* ((copy (tree:copy-node tree t))
         (inputs (collect-on-tree (lambda (n) (typep n 'd:input-argument)) copy))
         boxes)
    (dolist (n inputs)
      (when (tree:parent n)
        (pushnew (tree:parent n) boxes))
      (setf (quantity n) (u:string2 (answer n)))
      (collapse-input-argument n))
    (loop for i in (permute-tree copy nil boxes)
       ;; other functions depend on this list being sorted by ID
       collect (sort (mapcar (lambda (n)
                               (cons (id n) (u:string2 (quantity n))))
                             (collect-on-tree (lambda (n) (find (id n) inputs :key 'id))
                                              i))
                     '< :key 'first))))

(defun empty-green-boxes-p (tree)
  "Return T if there are any empty green boxes."
  (and (find-if-on-tree (lambda (n)
                          (and (typep n 'input-argument)
                               (null (quantity n))))
                        tree)
       t))

(defun no-more-valid-operations-p (diagram operations)
  (loop for i in operations
     never (find-transformation-for (root diagram) (transformations i) t)))
